home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-01
/
cexpert.zip
/
MCH8.LST
< prev
next >
Wrap
File List
|
1990-09-15
|
21KB
|
794 lines
Listing 8-1 A Sample C Program for Forward Chaining
/*
** forward.c
**
** Description: This program is to implement the forward chain in reasoning
*/
/*--------------------------------------------------include-------------*/
#include <stdio.h>
#include <math.h>
#include "cons.h"
#include "rule.h"
#include "fact.h"
/*----------------------------------------------forward_chain()--------*/
/*
** E.g.
**
** Rule Base:
** 1 IF ((d ?x)) THEN (c ?x) 1.0
** 2 IF ((a ?x)(c ?x)) THEN (b ?x) 1.0
** Predicate Base:
** ((d 2), 0.7);
**
** predicate = (a 2), certainty = 0.9, rule_base = RuleDataBase
**
** forward_chain(predicate,certainty,rule_base) ===>
** New Predicate Base:
** ((d 2), 0.7), ((a 2), 0.9), ((c 2), 0.7), ((b 2), 0.7)
**
*/
void forward_chain(predicate,certainty,rule_base)
cons *predicate; /*predicate of beginning fact*/
double certainty; /*certainty of beginning fact*/
rule *rule_base; /*rule base*/
/*----------------------------------------------------------------------*/
{
int i; /*loop variable*/
int flag = 0; /*flag to show rule base status*/
double *cert,cert1; /*certainty of new fact*/
double *fact_cert;
rule *rulep; /*rule base pointer*/
fact *factp,*new_fact;
cons *subst = NULL;
cons *new_concl,*temp;è extern cons *lookup_pkb_fact1();
cert1 = 1.0;
factp = PkbList; /*initial to fact base*/
rulep = rule_base; /*initial to rule base*/
pkb_stash(predicate,certainty); /*stash the fact into fact_base*/
while(rulep != NULL) /*search all the rule base*/
{
/*only concern conjunction*/
for(i = 1; i <= length(rulep->premise); i++)
{
temp = nth_list(i,rulep->premise);
subst=lookup_pkb_fact1(CAR(temp),fact_cert);
if(subst != NULL) /*find a matched rule's part*/
{
flag = 1; /*set up success flag*/
rulep->premise = subst_prop(rulep->premise,subst);
rulep->conclusion = subst_pred(rulep->conclusion,subst);
Min(cert1,(*fact_cert),cert); /*MYCIN certainty calcul*/
cert1 = (*cert);
}
else
{
flag = 0;
break;
}
}
if (flag == 1) /*find fact unified with premise*/
{
flag = 0; /*reset the flag*/
/*get the substituted rule conclusion*/
new_concl = rulep->conclusion;
cert1 = cert1*rulep->certainty;/* MYCIN certainty cal*/
pkb_stash(new_concl,cert1);
cert1 = 1.0; /*reset the certainty*/
rule_base = delete_rule(rulep,rule_base);/*the fired rule is kicked out*/
rulep = rule_base; /*restart search rule base*/
}
else
{
rulep = rulep->next; /*search for next rule*/
}
factp = PkbList; /*restart search fact base*/
}
}
/*
** stash_fact_pkb(predicate,cert)
** Before stash the fact into pkb, check whether it is already there or not
**
*/
stash_fact_pkb(pred,cert)
cons *pred; /*predicate calculus format of fact*/
double cert; /*fact's certainty*/
{
cons *fp;
double *cert_out;
fp = lookup_pkb_fact(pred,cert_out);
if(fp == NULL)
{
pkb_stash(pred,cert);
}
else /*the fact is already there*/
return;
}
/*-----------------------------------------------lookup_pkb_fact1()--------*/
/*
** Different from the lookup_pkb_fact() in facts.c file. The difference is
** the argument.
*/
cons *lookup_pkb_fact1(pattern,cert)
cons *pattern;
double *cert;
{
fact *fp = PkbList;
cons *subst = NULL;
*cert = 0.0;
while (fp) {
subst = unify_pred_c(pattern,fp->predicate);
if (subst != NULL) {
*cert = fp->cert;
break;
} else {
fp = fp->next;
}
}
return subst;
}
Listing 8-2 A Sample Program for Substitution
/*
** substitu.c: Functions for manipulating substitutions.
**
**
*/
/*--------------------------------------------------include--------------*/
#include <stdio.h>
#include "cons.h"
/*--------------------------------------------------twotees()------------*/
cons *twotees()
{
static cons *tt = NULL;
if (tt == NULL) {
tt = mklist2("t","t");
}
return tt;
}
/*--------------------------------------------------ltwotees()------------*/
cons *ltwotees()
{
static cons *ltt = NULL;
if (ltt == NULL) {
ltt = mkcons(CAR_LIST,twotees(),NULL);
}
return ltt;
}
/*--------------------------------------------------lltwotees()------------*/
cons *lltwotees()
{
static cons *lltt = NULL;
if (lltt == NULL) {
lltt = mkcons(CAR_LIST,ltwotees(),NULL);
}
return lltt;
}
/*--------------------------------------------------join_subst()------------*/
/*
** z1 is subst for ONE term.
*/
cons *join_subst(z1,z2)
cons *z1,*z2;
{
cons *retval;
if (equal(z1,ltwotees())) {
return z2;
} else if (equal(z2,ltwotees())) {
return z1;
} else {
return(mkcons(CAR_LIST,z1,z2));
}
}
/*--------------------------------------------------subst_list()------------*/
/*
** Variable substitution
** %% Use of system fn like subst would be real efficient, except that it
** does not deal with nonrecursiveness.
** Performs a variable substitution on list, nonrecursively
** (only one substitution applied to each atomic term).
** Usage: E.g. subst_list((p ?x ?y),((?x 1)(?y 2))) ===> (p 1 2)
*/
cons *subst_list(list,substi)
cons *substi,*list;
{
cons *new_list = NULL;
cons *substp;
cons *term;
cons *tmp;
while (list != NULL) {
term = list->car.p;
substp = substi; /* get 1st substitution */
while (substp != NULL) {
if (term->type == CAR_STRING && !strcmp(term->car.s,
substp->car.p->car.p->car.s)) {
term = substp->car.p->cdr->car.p;
break;
}
substp = substp->cdr; /* make more subst's */
}
new_list = nconc(new_list,mkcons(CAR_LIST,copy_list(term),NULL));
list = list->cdr;è }
return new_list;
}
/*--------------------------------------------------subst_prop()------------*/
/*
** subst_prop(): performs a variable substitution on proposition
** Returns a copy of the proposition with replacements according to the
** substitution list.
** Usage: E.g. subst_prop(((p ?x)(q ?y)),((?x 1)(?y 2))) ===> ((p 1)(q 2))
**
*/
cons *subst_prop(list,substi)
cons *substi,*list;
{
int i;
cons *temp1,*temp2;
temp1 = NULL;
if(list == NULL)
{
killcons(temp1);
killcons(temp2);
return NULL;
}
for(i = 1; i <= length(list); i++)
{
temp2 = nth_list(i,list);
temp1 = nconc(temp1,
mkcons(CAR_LIST,subst_list(CAR(temp2),substi),NULL));
}
killcons(temp1);
killcons(temp2);
return temp1;
}
/*--------------------------------------------------subst_pred()------------*/
/*
** subst_pred(): Performs nonrecursive variable substitution on a predicate
** Would be more mem-efficient if result SHARED with pred.
** Usage: E.g. subst_pred((p ?x ?y),((?x 1)(?y 2))) ===> (p 1 2)
*/
cons *subst_pred(pred,subst)
cons *pred,*subst;
{
return subst_list(pred,subst);
}
cons *substitute_pred(pred,subst)
cons *pred,*subst;
{
int i,j;
cons *new_list = NULL;
cons *substp;
cons *term;
cons *tmp;
for(i = 1; i <= length(pred); i++)
{
/* term = CAR(nth_list(i,pred));*/
substp = subst;
for(j = 1; j <= length(subst); j++)
{
;
}
}
}
/*--------------------------------------------------subst_substlist()-----*/
/*
** subst_substlist(): perform a substitution on a substitution list
** s-s( (((?x 1)) ((?x 2))) , ((?x ?y)) ) ==> (((?y 1)) ((?y 2)))
*/
cons *subst_substlist(substlist,subst)
cons *substlist,*subst;
{
cons *new_substlist = NULL;
cons *new_subst = NULL;
cons *new_pair = NULL;
cons *term,*substp,*substip,*tmp;
while (substlist != NULL) { /* for each substitution */
new_subst = NULL;
substp = substlist->car.p;
while (substp != NULL) { /* for each pair */
term = substp->car.p->car.p;
substip = subst;
while (substip != NULL) { /* for each substitution-pair */
if (!strcmp(term->car.s,substip->car.p->car.p->car.s)) {
term = substip->car.p->cdr->car.p;
break;
}
substip = substip->cdr;
}
new_subst = nconc(new_subst,
mkcons(CAR_LIST,
mkcons(CAR_LIST,
copy_list(term),
mkcons(CAR_LIST,copy_list(substp->car.p->cdr->car.p), NULL)),
NULL));
substp = substp->cdr;
}
new_substlist = nconc(new_substlist,mkcons(CAR_LIST,new_subst,NULL));
substlist = substlist->cdr;
}
return new_substlist;
}
/*----------------------------------------------test_subst_used()-----*/
/*
** test_subst_used():Tells if substitution has been used.
** Usage: E.g.
** test_subst_used(((?x 5)),(((?x 1)))) ===> 0
** test_subst_used(((?x 5)),(((?x 5)))) ===> 1
**
*/
int test_subst_used(list1,prev_subst)
cons *list1,*prev_subst;
{
int i,j;
int flag = 0;
cons *temp1,*temp2;
for(i=1;i<=length(list1);i++)
{
flag = 0;
temp1 = nth_list(i,list1);
for(j=1;j<=length(prev_subst);j++)
{
temp2 = nth_list(j,prev_subst);
if(equal(temp1,CAR(temp2)))
{
flag = 1;
break;
}
}
if(flag == 1)
{
return 1; /*at least one not used*/
}
}
return 0; /*all used*/
}
Listing 8-3 A Sample Program for Backward Chaining
/*
** backward.c
** Description: This program is to implement backward chain in the
** reasoning.
** Usage: E.g.
** Rule Base:
** 1. IF ((a ?x)(b ?x)) THEN (c ?x) 1.0
** Predicate Base:
** ((c 2), 1.0)
** previous substitutions: NULL
** backward_chain((c ?y),NULL) ===> ((?y 2), 1.0)
*/
/*-----------------------------------------------------------include-----*/
#include <stdio.h>
#include <math.h>
#include "cons.h"
#include "rule.h"
#include "fact.h"
#include "goal.h"
/*-----------------------------------------------------------define-------*/
#define ONE 1
#define TWO 2
/*
** backward_chain
*/
/*-------------------------------------------------------backward_chain()---*/
Ret_Pair *backward_chain(goal,prev_subs)
cons *goal; /*the goal trying to achieve*/
cons *prev_subs; /*previous substitution list*/
/*-------------------------------------------------------------------------*/
{
int flag = 0;
rule *rp;
cons *subs,*concl_pred_subst,*subst_for_vars,*subbed_prem;
cons *prem_prev_substs,*prem_subs,*true_concl_pred_subst;
cons *true_concl_pred,*tmp1,*tmp2;
cons *possible_subst;
Ret_Pair *ret_pair,*temp1;
#ifdef DEBUG
printf("\nIn backward_chain:");
printf("\ngoal: ");è lprint(goal,C_FILE,stdout);
printf(" prev_substs: ");
lprint(prev_subs,C_FILE,stdout);
#endif
possible_subst=NULL;
subs = NULL;
true_concl_pred = NULL;
rp = RuleDatabase; /*point to Rule base*/
ret_pair = init_ret_pair(); /*initialize the ret_pair*/
temp1 = init_ret_pair();
while( rp != NULL) /*trying to find a match rule*/
{
subs = unify_pred_nv(rp->conclusion,goal);
if(subs != NULL) /*find a rule match goal*/
{
flag = 1; /*find a rule*/
break;
}
rp = rp->next;
}
if(!flag) /*not find match rule, back*/
{
return ret_pair;
}
tmp1 = nth_list(ONE,subs);
tmp2 = nth_list(TWO,subs);
concl_pred_subst = CAR(tmp1);
subst_for_vars = CAR(tmp2);
subbed_prem = subst_prop(rp->premise,concl_pred_subst);
if(length(subbed_prem) == 1) /*not conjunction premise*/
{
subbed_prem = CAR(subbed_prem);
}
prem_prev_substs = subst_substlist(prev_subs,subst_for_vars);
temp1 = achieve(subbed_prem,prem_prev_substs);
prem_subs = temp1->subst;
if(prem_subs != NULL)
{
true_concl_pred_subst = nconc(concl_pred_subst,prem_subs);
true_concl_pred = subst_pred(rp->conclusion,true_concl_pred_subst);
possible_subst = unify_pred_c(goal,true_concl_pred);
if(!test_subst_used(possible_subst,prev_subs)) /*not used in prev*/
{
ret_pair->subst = possible_subst;
ret_pair->certainty = rp->certainty * temp1->certainty;
}
}
#ifdef DEBUG
printf("\nreturn from backward_chain:");
printf("\nret_pair->subst::");
lprint(ret_pair->subst,C_FILE,stdout);
printf(" ret_pair->certainty::%g",ret_pair->certainty);
#endif è return ret_pair;
}
Listing 8-4 A Sample Program for Forward Tracking
/*
** frwdtrack.c
** Description: This program is to implement forward track step
** in reasoning.
*/
/* Returns the substitution that makes conjuncts true. (Does NOT return
** solution with s_i_t; that should be prepended by caller)
** If prev_substs is specified then we're calling the conjunct for the first
** time, but where some solutions have been tried already elsewhere
*/
/*------------------------------------------------------include---------*/
#include <stdio.h>
#include <math.h>
#include "cons.h"
#include "goal.h"
/*------------------------------------------------------frwdtrack()------*/
Ret_Pair *Frwdtrack(gs_obj,conjuncts,subs_in_there,prev_substs)
Goal_Stack *gs_obj; /*goal stack object*/
cons *conjuncts; /*conjuncts list*/
cons *subs_in_there; /*substitutions in there*/
cons *prev_substs; /*previous substitution list*/
/*-----------------------------------------------------------------------*/
{
Ret_Pair *ret_pair; /*return pair: subst,cert*/
Ret_Pair *temp_pair1,*temp_pair2;
Goal_Frame *goal_frame;
cons *temp1,*tmp1;
double *cert;
#ifdef DEBUG
printf("\nIn Frwdtrack");
printf("\ngs_obj ::");
print_goal_obj(gs_obj);
printf("\nconjuncts :: ");
lprint(conjuncts,C_FILE,stdout);
printf(" sit :: ");
lprint(subs_in_there,C_FILE,stdout);
printf(" prev_substs :: ");
lprint(prev_substs,C_FILE,stdout);
#endif
ret_pair = init_ret_pair();
temp_pair1 = init_ret_pair();
if(conjuncts == NULL)è {
ret_pair->subst = mkcons(CAR_LIST,mklist2("t","t"),NULL);
ret_pair->certainty = 1.0;
return ret_pair;
}
else
{
temp_pair1 = achieve(CAR(conjuncts),prev_substs);
if(temp_pair1->subst != NULL)
{
if (goal_frame = (Goal_Frame *) malloc(sizeof(Goal_Frame)))
{
goal_frame->goal = CAR(conjuncts);
goal_frame->sit = subs_in_there;
goal_frame->ps = prev_substs;
goal_frame->roc = CDR(conjuncts);
goal_frame->soln = temp_pair1->subst;
goal_frame->cert = temp_pair1->certainty;
push_a_frame(goal_frame,gs_obj);
tmp1 = subs_in_there;
temp_pair2 = Frwdtrack(gs_obj,
subst_prop(CDR(conjuncts),temp_pair1->subst),
nconc(tmp1,temp_pair1->subst),prev_substs);
if(temp_pair2->subst != NULL)
{
ret_pair->subst =
nconc(temp_pair1->subst,temp_pair2->subst);
Min(temp_pair1->certainty,temp_pair2->certainty,cert);
ret_pair->certainty = (*cert);
return ret_pair;
}
else
{
return Backtrack(gs_obj,TRUE);
}
}
else
{
puts("\n*** Yow! Out of core ***\n");
}
}
else
{
ret_pair->subst = NULL;
ret_pair->certainty = 0.0;
return ret_pair;
}
}
}
Listing 8-5 A Sample Program for Achieve-Goal
/*
** achieve.c
**
** Description: This program is to implement backward reasoning.
**
** Include: achieve(),achieve_conjunction();
**
*/
/*--------------------------------------------------------include--------*/
#include <stdio.h>
#include <math.h>
#include "cons.h"
#include "rule.h"
#include "fact.h"
#include "goal.h"
/*--------------------------------------------------achieve_conjunction----*/
/*
** achieve_conjunction():
**
** If we're backtracking with prev_substs and there is no saved
** goal on the stack, that could mean
** that we haven't tried the goal yet at all and the prev_substs
** are from somewhere else.
**
** Return struct Ret_Pair (pair of substitution,certainty).
**
** E.g.
**
** Predicate Base:
** ((a 1), 1.0), ((a 2), 1.0), ((b 2), 0.9)
**
** achieve_conjunction(((a ?x)(b ?x)),NULL) ===> (((?x 2)), 0.9)
**
**
*/
Ret_Pair *achieve_conjunction(conjunction,prev_substs)
cons *conjunction;
cons *prev_substs;
/*------------------------------------------------------------------------*/
{
Ret_Pair *ret_pair,*temp1;
Goal_Stack *gs_obj;
Goal_Frame *gf;
cons *tmp1;è
#ifdef DEBUG
printf("\nIn Achieve_Conjunction");
printf("\nconjunction == ");
lprint(conjunction,C_FILE,stdout);
printf(" prev_substs == ");
lprint(prev_substs,C_FILE,stdout);
#endif
gs_obj = NULL;
ret_pair = init_ret_pair();
gs_obj = Find_Goal_Stack(conjunction,prev_substs);
if(prev_substs == NULL || gs_obj == NULL)
{
gs_obj = Create_Goal_Stack(conjunction);
Add_Goal_Stack(gs_obj); /*push into goal stack*/
ret_pair = Frwdtrack(gs_obj,conjunction,NULL,prev_substs);
}
else
{
temp1 = Backtrack(gs_obj,FALSE);
if(temp1->subst != NULL)
{
gf = gs_obj->goal_frame_list;
tmp1 = gf->sit;
ret_pair->subst = nconc(tmp1,gf->soln);
ret_pair->certainty = temp1->certainty;
}
}
if(ret_pair->subst != NULL)
{
gs_obj->prev_subst = push(ret_pair->subst,gs_obj->prev_subst);
}
#ifdef DEBUG
printf("\nreturn from Achieve_conjunction");
printf("\nret_pair.subst == ");
lprint(ret_pair->subst,C_FILE,stdout);
printf("ret_pair.cert == %g",ret_pair->certainty);
#endif
return ret_pair;
}
/*-------------------------------------------------------achieve()--------*/
/*
** Attempts to achieve goal, returning a substitution and certainty
** Only dealing with the conjunction premises.
**
** E.g.
**
** Rule Base:è** 1 IF ((a ?z)) THEN (b ?z) 1.0
** 2 IF ((b ?w)) THEN (c ?w) 0.9
** 3 IF ((c ?x)(d ?x)) THEN (e ?x) 1.0
** 4 IF ((e ?x)) THEN (f ?x) 0.8
** Predicate Base:
** ((a 6), 0.8), ((a 3), 0.6), ((d 3), 1.0)
**
** achieve((f ?y),NULL) ===> (((?y 3)), 0.432)
**
*/
Ret_Pair *achieve(goal,prev_substs)
cons *goal;
cons *prev_substs;
/*-------------------------------------------------------------------------*/
{
Ret_Pair *ret_pair;
#ifdef DEBUG
printf("\nIn achieve.c");
printf("\ngoal == ");
lprint(goal,C_FILE,stdout);
printf(" prev_substs == ");
lprint(prev_substs,C_FILE,stdout);
#endif
ret_pair = init_ret_pair();
if(!equal(prev_substs,ltwotees()))
{
if(!ATOM(CAR(goal))) /*only deal with conjunction*/
{
ret_pair = achieve_conjunction(goal,prev_substs);
}
else
{
ret_pair = lookup_pkb_fact(goal,prev_substs);
if(ret_pair->subst == NULL) /*not find in pkb*/
{
ret_pair = backward_chain(goal,prev_substs);
}
}
}
#ifdef DEBUG
printf("\nreturn from Achieve.c");
printf("\nret_pair.subst == ");
lprint(ret_pair->subst,C_FILE,stdout);
printf("ret_pair.cert == %g",ret_pair->certainty);
#endif
return ret_pair;
}